{-# LANGUAGE DeriveDataTypeable #-}
----------------------------------------------------------------
--                                                            --
-- Module      :  LLVM.Code.Constant                          --
-- License     :  GPL3                                        --
-- Mantainer   :  Mikhail Belyaev                             --
--                                                            --
----------------------------------------------------------------

module LLVM.Code.Constant where

import Data.Generics(Typeable, Data)

import LLVM.Code.Shared
       (BinOpcode(..), CastOpcode, BinOpcode, BBIndex(..), TypeIndex(..),
        ValIndex(..))
import LLVM.Parser.Record.Record
       (RawBlock(..), fromData, BlockHeader(..), BlockType(..),
        recordAsList, RecordType(..))

import LLVM.Util
import Data.Maybe (catMaybes)
import Control.Monad (liftM)
import LLVM.Code.Types (Type(..), getTypeByIndex)
import LLVM.Code.Values.Kinds (ConstantValue(..), ConstantValue)
import LLVM.Code.Values (Value(..), TypedValue(..))

--    CST_CODE_SETTYPE       =  1,  // SETTYPE:       [typeid]
--    CST_CODE_NULL          =  2,  // NULL
--    CST_CODE_UNDEF         =  3,  // UNDEF
--    CST_CODE_INTEGER       =  4,  // INTEGER:       [intval]
--    CST_CODE_WIDE_INTEGER  =  5,  // WIDE_INTEGER:  [n x intval]
--    CST_CODE_FLOAT         =  6,  // FLOAT:         [fpval]
--    CST_CODE_AGGREGATE     =  7,  // AGGREGATE:     [n x value number]
--    CST_CODE_STRING        =  8,  // STRING:        [values]
--    CST_CODE_CSTRING       =  9,  // CSTRING:       [values]
--    CST_CODE_CE_BINOP      = 10,  // CE_BINOP:      [opcode, opval, opval]
--    CST_CODE_CE_CAST       = 11,  // CE_CAST:       [opcode, opty, opval]
--    CST_CODE_CE_GEP        = 12,  // CE_GEP:        [n x operands]
--    CST_CODE_CE_SELECT     = 13,  // CE_SELECT:     [opval, opval, opval]
--    CST_CODE_CE_EXTRACTELT = 14,  // CE_EXTRACTELT: [opty, opval, opval]
--    CST_CODE_CE_INSERTELT  = 15,  // CE_INSERTELT:  [opval, opval, opval]
--    CST_CODE_CE_SHUFFLEVEC = 16,  // CE_SHUFFLEVEC: [opval, opval, opval]
--    CST_CODE_CE_CMP        = 17,  // CE_CMP:        [opty, opval, opval, pred]
--    CST_CODE_INLINEASM     = 18,  // INLINEASM:     [sideeffect,asmstr,conststr]
--    CST_CODE_CE_SHUFVEC_EX = 19,  // SHUFVEC_EX:    [opty, opval, opval, opval]
--    CST_CODE_CE_INBOUNDS_GEP = 20,// INBOUNDS_GEP:  [n x operands]
--    CST_CODE_BLOCKADDRESS  = 21   // CST_CODE_BLOCKADDRESS [fnty, fnval, bb#]



data ConstantDef = ConstantDef { ctype :: TypeIndex, cvalue :: ConstantValue } deriving (Show,Eq,Typeable,Data)

newtype ConstantBlock = ConstantBlock{ cdefs ::[ConstantDef] } deriving (Show,Eq)

instance RecordType ConstantValue where
    fromRawRecord rr = case (recordAsList rr) of
                            (_: 2:_) -> Just Null
                            (_: 3:_) -> Just Undefined
                            (_: 4:v:_) -> Just (IntegerC $ tosigned v)
                            (_: 5:vs) -> Just (WIntegerC $ map tosigned vs)
                            (_: 6:f:_) -> Just (FloatC $ fromInteger f)
                            (_: 7:vs) -> Just (Aggregate $ map ValIndex vs)
                            (_: 8:str) -> Just (StringC $ massOrd str)
                            (_: 9:str) -> Just (CStringC $ massOrd str)
                            (_:10:opc:v1:v2:_) -> case binOC of
                                                      Just binOp -> Just (BinOpC binOp vi1 vi2 )
                                                      otherwise -> Nothing
                                                 where binOC = beFromIntSafe opc
                                                       vi1 = ValIndex v1
                                                       vi2 = ValIndex v2
                            (_:11:opc:tp:v:_) -> case castOC of
                                                     Just cstOp -> Just (CastOpC cstOp ti vi )
                                                     otherwise -> Nothing
                                                 where castOC = beFromIntSafe opc
                                                       ti = TypeIndex tp
                                                       vi = ValIndex v
                            (_:12:_) -> Just GepOpC
                            (_:13:v1:v2:v3:_) -> Just (SelectOpC vi1 vi2 vi3)
                                              where vi1 = ValIndex v1
                                                    vi2 = ValIndex v2
                                                    vi3 = ValIndex v3
                            (_:14:t:v1:v2:_) -> Just (ExtractOpC ti vi1 vi2)
                                               where ti = TypeIndex t
                                                     vi1 = ValIndex v1
                                                     vi2 = ValIndex v2
                            (_:15:v1:v2:v3:_) -> Just (InsertOpC vi1 vi2 vi3)
                                                where vi1 = ValIndex v1
                                                      vi2 = ValIndex v2
                                                      vi3 = ValIndex v3
                            (_:16:v1:v2:v3:_) -> Just (ShuffleOpC vi1 vi2 vi3)
                                                where vi1 = ValIndex v1
                                                      vi2 = ValIndex v2
                                                      vi3 = ValIndex v3
                            (_:17:t:v1:v2:v3:_) -> Just (CmpOpC ti vi1 vi2 vi3)
                                                  where ti = TypeIndex t
                                                        vi1 = ValIndex v1
                                                        vi2 = ValIndex v2
                                                        vi3 = ValIndex v3
                            (_:18:_) -> Just InlineASM
                            (_:19:t:v1:v2:v3:_) -> Just (ShuffleOpCEx ti vi1 vi2 vi3)
                                                  where ti = TypeIndex t
                                                        vi1 = ValIndex v1
                                                        vi2 = ValIndex v2
                                                        vi3 = ValIndex v3
                            (_:20:ivs) -> Just (InBoundGEPOpC vs)
                                         where vs = map ValIndex ivs
                            (_:21:iti:ivi:ibbi:_) -> Just (BlockAddress ti vi bbi)
                                                    where ti = TypeIndex iti
                                                          vi = ValIndex ivi
                                                          bbi = BBIndex ibbi
                            otherwise -> Nothing

instance BlockType ConstantBlock where
    fromRawBlock rb | rb.$header.$blockId == 11 = Just $ ConstantBlock ( iter 0 records [] )
                                                 where records = maybeFilter fromData $ rb.$contents
                                                       iter ti (rec:rs) ret =
                                                          case (recordAsList rec) of
                                                               (_:1:v:_) -> iter (TypeIndex v) rs ret
                                                               otherwise -> iter ti rs $ (liftM (ConstantDef ti) (fromRawRecord rec)):ret
                                                       iter _ [] ret = catMaybes ret
    fromRawBlock _ = Nothing




emptyConsts :: ConstantBlock
emptyConsts = ConstantBlock []

instance TypedValue ConstantDef where
    getType (ConstantDef ti _) tt = getTypeByIndex tt ti ?? error "Constant definition type not found"
    toValue (ConstantDef _ cv) = ConstantV cv





